Análisis de Regresión con R

Comparación de modelos de regresión con R

Artículo científico

Datos

• Datos tomados del artículo referenciado previamente.
• Fuente de datos - Artículo en PLOS | ONE.
• En la base de datos se tienen dos grupos bajo análisis:
  • Grupo Long jumpers: id 1 a 23.
  • Grupo untrained men: id 24-45.

Lectura de datos

library(readxl)
library(tidyverse)
datos <- read_xlsx("../data/Data_Paper_Plos_One_Muscle.xlsx", skip = 3,
                   na = "N/A", n_max = 47) %>% 
  rename(RA_takeof_leg = RA...7,
         OB_takeof_leg = OB...8,
         PM_takeof_leg = PM...9,
         QL_takeof_leg = QL...10,
         ES_takeof_leg = ES...11,
         Gmax_takeof_leg = Gmax...12,
         Gmed_takeof_leg = Gmed...13,
         IL_takeof_leg = IL...14,
         RA_free_leg = RA...15,
         OB_free_leg = OB...16,
         PM_free_leg = PM...17,
         QL_free_leg = QL...18,
         ES_free_leg = ES...19,
         Gmax_free_leg = Gmax...20,
         Gmed_free_leg = Gmed...21,
         IL_free_leg = IL...22,
         id = ID,
         edad = `Age (years)`,
         altura_cm = `Height (cm)`,
         imc = `Body mass (kg)`,
         dist_salto_cm = `long jump distance (cm)`,
         sprint_100m_seconds = `100-m sprint time (s)`,
         grasa_subcut_cm2 = `Subcutaneous fat CSA (absolute value, cm2)`) %>% 
  mutate(type = if_else(id %in% c(1:23), true = "Long jumpers",
                        false = "Untrained men"))
datos

Objetivos

• Replicar análisis estadísticos aplicados en el artículo científico de interés.
• Evidenciar la relación existente entre características anatómicas de atletas vs rendimiento en salto largo.
• Evaluar otros métodos de statistical learning y compararlos con los resultados obtenidos por los autores.

Resultados del paper

Correlaciones

• Aunque fueron numerosos los resultados obtenidos por los autores, para el objetivo de este documento se destacan los siguientes:
  • La relación entre el área transversal relativa (CSA) del recto abdominal (AR) del lado de la pierna de despegue y el mejor registro personal para el salto largo.
    • Correlación: 0.674
    • Valor p: 0.004 (estadísticamente significativo)
• Las correlaciones (con intervalo de confianza del 95%) se presentan en la siguiente tabla:

Gráfico de dispersión

Original

Réplica con R

library(ggplot2)
datos %>% 
  ggplot(data = ., aes(x = RA_takeof_leg, y = dist_salto_cm)) +
  geom_point(size = 3) +
  labs(x = expression('Relative CSA of RA takeoff leg side - cm'^"2"/'kg'^"2/3"),
       y = "Personal best record of long jump (cm)") +
  geom_smooth(method = "lm", se = FALSE, lty = 3, lwd = 1, color = "black") +
  theme_light()

Predichos vs Reales (paper)

Resultados adicionales con R

Distribuciones

datos %>% 
  select_if(is.numeric) %>% 
  select(-id) %>% 
  gather(key = "variable", value = "valor") %>% 
  ggplot(data = ., aes(x = valor)) +
  facet_wrap(facets = ~variable, scales = "free", ncol = 4) +
  geom_histogram(aes(y = ..density..), bins = 10, color = "black", 
                 fill = "gray60") +
  geom_density(fill = "gray50", alpha = 0.18) +
  geom_rug() +
  labs(x = "", y = "Densidad") +
  theme_light() +
  theme(strip.background = element_rect(fill = "deepskyblue4"),
        strip.text = element_text(color = "black"))

Gráficos cuantil cuantil

library(qqplotr)
datos %>% 
  select_if(is.numeric) %>% 
  select(-id) %>% 
  gather(key = "variable", value = "valor") %>% 
  ggplot(data = ., aes(sample = valor)) +
  facet_wrap(facets = ~variable, scales = "free", ncol = 4) +
  geom_qq_band(fill = "gray25") +
  stat_qq_line(color = "darkgreen") +
  stat_qq_point(color = "black", size = 0.8) +
  labs(x = "Cuantiles teóricos", y = "Cuantiles muestrales") +
  theme_light() +
  theme(strip.background = element_rect(fill = "deepskyblue4"),
        strip.text = element_text(color = "black"))

Comparativos

• Se comparan registros de cross-sectional area (CSA) de la pierna de despeque (takeoff) vs la pierna libre (free). Las variables (músculos) a comparar son las siguientes:
  • RA: recto abdominal.
  • OB: oblicuos internos y externos.
  • PM: psoas mayor.
  • QL: cuadrado lumbar.
  • ES: erector spinae.
  • Gmax: gluteo mayor.
  • Gmed: gluteos medio y mínimo.
  • IL: iliaco

df_takeoff_leg <- datos %>% 
  select(RA_takeof_leg:IL_takeof_leg) %>% 
  gather(key = "variable", value = "valor") %>% 
  mutate(tipo = "TakeoffLeg")

df_free_leg <- datos %>% 
  select(RA_free_leg:IL_free_leg) %>% 
  gather(key = "variable", value = "valor") %>% 
  mutate(tipo = "FreeLeg")

df_takeoff_free <- df_takeoff_leg %>% 
  bind_rows(df_free_leg)

df_takeoff_free %>% 
  separate(col = variable, into = c("variable", "v1", "v2")) %>% 
  select(-c(v1, v2))  %>% 
  ggplot(data = ., aes(x = tipo, y = valor, fill = tipo)) +
  facet_wrap(facets = ~variable, scales = "free", ncol = 4) +
  geom_boxplot(color = "black") +
  scale_fill_manual(values = c("darkgreen", "gold4")) +
  labs(x = "Tipo de pierna", y = "") +
  theme_light() +
  theme(strip.background = element_rect(fill = "deepskyblue4"),
        strip.text = element_text(color = "black"),
        legend.position = "none")

Shapiro Wilk

Se comprueba la normalidad de las variables (\(\alpha = 0.05\)), bajo el siguiente juego de hipótesis:

\[H_0: X \sim N(\mu, \sigma^2)\\ H1: x \nsim N(\mu, \sigma^2)\]

datos %>% 
  select_if(is.numeric) %>% 
  select(-id) %>% 
  gather(key = "variable", value = "valor") %>% 
  group_by(variable) %>% 
  summarise(valor = list(valor)) %>% 
  ungroup() %>% 
  group_by(variable) %>% 
  mutate(shapiro_valorP = round(shapiro.test(unlist(valor))$p.value, digits = 5),
         Resultado = if_else(shapiro_valorP <= 0.05, true = "No normalidad",
                             false = "Sí normalidad"))  %>% 
  select(-valor)

• Nota: aunque los autores mencionan que fueron aplicadas las pruebas de Shapiro Wilk para comprobar el supuesto de normalidad, en la tabla anterior se evidencia que algunas variables (ej. distancia de salto, grasa subcutanea, entre otras) no se distribuyen de forma normal. Este resultado tiene connotaciones de importancia, ya que las correlaciones podrían ser obtenidas mediante métodos no paramétricos.

Matriz de correlaciones

• Se construye la matriz de correlaciones (método de Pearson).
• La variable que presente mayor correlación lineal con la longitud del salto, será tenida en cuenta para estructurar el modelo de regresión lineal simple (RLS). Con las demás variables se construye el modelo de regresión lineal múltiple (RLM).

library(corrplot)
library(RColorBrewer)
datos %>% 
  select_if(is.numeric) %>% 
  select(-id) %>% 
  cor(use = "complete.obs") %>% 
  corrplot(method = "pie",
           type = "upper",
           diag = FALSE,
           tl.cex = 0.8,
           tl.srt = 45,
           addgrid.col = "black",
           order = "hclust",
           col = brewer.pal(n = 10, name = "Spectral"))

• Notas:
  • Se evidencia alta correlación entre algunas variables. Este patrón sugiere problemas de multicolinealidad al ajustar un modelo de RLM.
  • Atletas con mayor altura tienden a presentar saltos de menor distancia. Este comportamiento es obtenido de igual forma en aquellos que aumentan la velocidad del sprint al saltar, es decir, que a mayor velocidad, menor longitud de salto.
  • Atletas con el músculo recto abdominal de mayor longitud, presentan mayores distancias en sus saltos. Con esta variable se ajusta el modelo de RLS.

Regresión Lineal Simple (RLS)

• Se propone cuantificar la unidad de cambio en la distancia del salto vs la longitud (cm²/kg^2/3) del músculo recto abdominal (RA), para la pierna de despegue (takeoff).
• El modelo de RLS puede ser expresado de la siguiente manera: \[Y = \beta_0\ + \beta_1X \\ \hat{Y} = \hat{\beta_0}\ + \hat{\beta_1}X\ + \epsilon\]
• Escrito de cara al fenómeno bajo estudio, el modelo queda expresado como sigue: \[Distancia = \hat{\beta_0}\ + (\hat{\beta_1}\times RA) + \epsilon\]
• Este modelo de RLS es ajustado a través del Método de Mínimos Cuadrados.

Modelo Lineal con lm()

mod_rls <- lm(dist_salto_cm ~ RA_takeof_leg, data = datos)
summary(mod_rls)

Call:
lm(formula = dist_salto_cm ~ RA_takeof_leg, data = datos)

Residuals:
   Min     1Q Median     3Q    Max 
-72.26 -22.41   8.38  22.24  65.10 

Coefficients:
              Estimate Std. Error t value Pr(>|t|)    
(Intercept)    589.584     49.894  11.817 9.66e-11 ***
RA_takeof_leg   11.928      4.443   2.685   0.0139 *  
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residual standard error: 40.89 on 21 degrees of freedom
  (22 observations deleted due to missingness)
Multiple R-squared:  0.2555,    Adjusted R-squared:  0.2201 
F-statistic: 7.208 on 1 and 21 DF,  p-value: 0.01387

• Nota: el resultado anterior sugiere que la variable RA_takeof_leg es estadísticamente significativa (\(valor\ p =0.0139\)) sobre la variabilidad observada en la distancia del salto. Además, se puede inferir que por cada unidad que aumenta RA_takeof_leg, la distancia de salto es 11.928 centímetros mayor. La variable RA_takeof_leg explica 22.01% de la variabilidad observada en la distancia de salto.

Significancia Estadística

anova(mod_rls)

Analysis of Variance Table

Response: dist_salto_cm
              Df Sum Sq Mean Sq F value  Pr(>F)  
RA_takeof_leg  1  12050 12050.0  7.2078 0.01387 *
Residuals     21  35108  1671.8                  
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

Residuales

par(mfrow = c(2, 2))
plot(mod_rls)

• Normalidad (Shapiro Wilk) de los residuales:

shapiro.test(residuals(mod_rls))

    Shapiro-Wilk normality test

data:  residuals(mod_rls)
W = 0.96191, p-value = 0.5029

• Heterocedasticidad - Breusch Pagan Test:

library(lmtest)
bptest(mod_rls)

    studentized Breusch-Pagan test

data:  mod_rls
BP = 0.0025838, df = 1, p-value = 0.9595

• Se comprueba que existe normalidad de los residuos y, además, son homocedasticos.

Reales vs Predichos

reales <- datos$dist_salto_cm[!is.na(datos$dist_salto_cm)]
predichos <- mod_rls$fitted.values
data.frame(
  Real = reales,
  Predichos = predichos
) %>% 
  ggplot(data = ., aes(x = Predichos, y = Real)) +
  geom_point() +
  labs(x = ("Valores predichos de distancia (cm)"),
       y = "Valores reales de distancia (cm)") +
  geom_smooth(method = "lm", se = FALSE, lty = 3, lwd = 1, color = "black") +
  theme_light()

• La correlación entre los valores reales y valores predichos por el modelo de RLS es: 0.505; más baja que la reportada por los autores al ajustar un modelo de RLM, cuyo valor es igual a 0.892

Regresión Lineal Múltiple (RLM)

• Para la construcción del modelo de RLM se comprueba la multicolinealidad de las variables y se proponen cuatro alternativas:
  • Modelo 1: Modelo de RLM con eliminación de variables por valores de correlación.
  • Modelo 2: Modelo de RLM con eliminación de variables por factor inflacionario de varianza.
  • Modelo 3: Modelo de RLM seleccionando predictores con el método Stepwise (utilizado por los autores del artículo).
  • Modelo 4: Modelo de regresión por componentes principales (mínimos cuadrados parciales).
• Los modelos son comparados a través del R² ajustado (mayor mejor) y el cuadrado medio del error (CME).

Modelo 1

Modelo 2

Modelo 3

Modelo 4